(* This file is part of IsoType.
 *
 * IsoType is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * IsoType is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with IsoType.  If not, see <http://www.gnu.org/licenses/>.
 *)

type qn_val = (Ast.qname, Ast.type_expr) Hashtbl.t 
type qn_typ = (Ast.qname, Ast.tvar list * Ast.type_body) Hashtbl.t

let rec make_absolute_name base_path qname =
  match base_path with
      [] -> qname
    | segment :: path -> make_absolute_name path (Ast.Segment (segment, qname))

let predefined_types =
  [
(*     [], "int", []; *)
(*     [], "bool", []; *)
(*     [], "float", []; *)
(*     [], "list", ["a"]; *)
(*     [], "array", ["a"]; *)
(*     [], "string", []; *)
(*     [], "char", []; *)
(*     [], "unit", []; *)
(*     [], "in_channel", []; *)
(*     [], "out_channel", []; *)
(*     [], "option", ["a"]; *)
(*     [], "ref", ["a"]; *)
(*     ["Lexing"], "lexbuf", []; *)
(*     ["Lexing"], "lex_tables", []; *)
(*     ["Parsing"], "parse_tables", []; *)
(*     ["Parsing"], "parser_env", []; *)
(*     ["Format"], "formatter", []; *)
(*     ["String"], "t", []; (\* ATTENZIONE: QUESTO DOVREBBE ESSERE UN ALIAS PER string *\) *)
(*     ["Obj"], "t", []; *)
(*     ["#Set"], "t", ["a"]; *)
(*     ["#Map"], "t", ["a"]; *)
(*     ["Hashtbl"], "t", ["a"; "b"]; *)
(*     ["Unix"], "tm", []; *)
  ]

let resolve entities flags =
  let values_tbl : qn_val = Hashtbl.create 1000
  and types_tbl : qn_typ = Hashtbl.create 1000 in
  let rec resolve_name base_path qname =
    let absolute_name = make_absolute_name base_path qname in
    if Hashtbl.mem types_tbl absolute_name then
      absolute_name
    else 
      match base_path with
	  [] -> qname (* E` GIUSTO??? *)
	| _ :: path' -> resolve_name path' qname
  in
  let rec map_type base_path =
    function
	Ast.Var _ as typ -> typ
      | Ast.Ref (typs, qname) ->
	  begin
	    match resolve_name base_path qname with
		Ast.Segment ("Set", Ast.Functor ("Make", mdule, Ast.Id "t")) ->
		  Ast.Ref ([Ast.Ref ([], resolve_name base_path (Ast.Segment (mdule, Ast.Id "t")))], Ast.Segment ("#Set", Ast.Id "t"))
        |	Ast.Segment ("Map", Ast.Functor ("Make", mdule, Ast.Id "t")) ->
		  Ast.Ref ([Ast.Ref ([], resolve_name base_path (Ast.Segment (mdule, Ast.Id
      "t")))], Ast.Segment ("#Map", Ast.Id "t"))
	      | qname' -> Ast.Ref (List.map (map_type base_path) typs, qname')
	  end
      | Ast.Arrow (typ1, typ2) -> Ast.Arrow (map_type base_path typ1, map_type base_path typ2)
      | Ast.Tuple typs -> Ast.Tuple (List.map (map_type base_path) typs)
  in
  let map_constructor base_path (Ast.Constructor (name, typs)) =
    Ast.Constructor (name, List.map (map_type base_path) typs)
  in
  let map_field base_path (Ast.Field (name, typ)) =
    Ast.Field (name, map_type base_path typ)
  in
  let map_type_body base_path =
    function
	Ast.Abstract -> Ast.Abstract
      | Ast.Alias typ -> Ast.Alias (map_type base_path typ)
      | Ast.Algebraic ctors -> Ast.Algebraic (List.map (map_constructor base_path) ctors)
      | Ast.Record fields -> Ast.Record (List.map (map_field base_path) fields)
  in
  let rec map_entity path = 
    function
	Ast.Type decls ->
	  (* Insert dummy declarations for the types *)
	  List.iter
	    (fun (_, name, _) -> 
	       Hashtbl.add types_tbl (make_absolute_name path (Ast.Id name)) ([], Ast.Abstract))
	    decls;
	  (* map bodies *)
	  let bodies = List.map (fun (_, _, body) -> map_type_body path body) decls in
	    (* Replace dummy declarations with correct ones *)
	    List.iter2 (fun (tvars, name, _) body ->
			  Hashtbl.replace types_tbl
			    (make_absolute_name path (Ast.Id name))
			    (tvars, map_type_body path body)) decls bodies

      | Ast.Value (name, typ) ->
	  if (not (StringAux.begins_with name "yy")) && (not (StringAux.begins_with name "__")) then
	      Hashtbl.add values_tbl (make_absolute_name path (Ast.Id name)) (map_type path typ)

      | Ast.Module (name, entities') ->
	  let full_path = Pp.string_of_qname (make_absolute_name path (Ast.Id name)) in
	    if not (List.exists (FunAux.flip StringAux.begins_with full_path) (Flags.ignore_modules flags)) then 
	      map_entities (name :: path) entities'
	    else if Flags.debug flags then 
	      print_endline (">>> Ignoring module " ^ full_path)

      | _ -> (* NOT IMPLEMENTED *) ()
  and map_entities path = List.iter (map_entity path)
  in
    List.iter
      (fun (base_path, name, vars) -> 
	 Hashtbl.add types_tbl (make_absolute_name base_path (Ast.Id name)) (vars, Ast.Abstract))
      predefined_types;
    map_entities [] entities;
    (types_tbl, values_tbl)
